home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / mitscheme.init < prev    next >
Text File  |  1999-04-19  |  8KB  |  275 lines
  1. ;;;"mitscheme.init" Initialization for SLIB for MITScheme        -*-scheme-*-
  2. ;;; Author: Aubrey Jaffer
  3. ;;;
  4. ;;; This code is in the public domain.
  5.  
  6. ;;; Make this part of your ~/.scheme.init file.
  7.  
  8. (define getenv get-environment-variable)
  9.  
  10. ;;; (software-type) should be set to the generic operating system type.
  11. (define (software-type) (if (getenv "HOMEDRIVE") 'MS-DOS 'UNIX))
  12.  
  13. ;;; (scheme-implementation-type) should return the name of the scheme
  14. ;;; implementation loading this file.
  15.  
  16. (define (scheme-implementation-type) 'MITScheme)
  17.  
  18. ;;; (scheme-implementation-home-page) should return a (string) URL
  19. ;;; (Uniform Resource Locator) for this scheme implementation's home
  20. ;;; page; or false if there isn't one.
  21.  
  22. (define (scheme-implementation-home-page)
  23.   "http://swissnet.ai.mit.edu/scheme-home.html")
  24.  
  25. ;;; (scheme-implementation-version) should return a string describing
  26. ;;; the version the scheme implementation loading this file.
  27.  
  28. (define (scheme-implementation-version)
  29.   (let* ((str (with-output-to-string identify-world))
  30.      (beg (+ (substring? "Release " str) 8))
  31.      (rst (substring str beg (string-length str)))
  32.      (end (string-find-next-char-in-set
  33.            rst
  34.            (predicate->char-set char-whitespace?))))
  35.     (substring rst 0 end)))
  36.  
  37. ;;; (implementation-vicinity) should be defined to be the pathname of
  38. ;;; the directory where any auxillary files to your Scheme
  39. ;;; implementation reside.
  40.  
  41. (define (implementation-vicinity)
  42.   (case (software-type)
  43.     ((MS-DOS)    "c:\\scheme\\")
  44.     ((UNIX)     "/usr/local/lib/mit-scheme/")
  45.     ((VMS)    "scheme$src:")))
  46.  
  47. ;;; (library-vicinity) should be defined to be the pathname of the
  48. ;;; directory where files of Scheme library functions reside.
  49.  
  50. (define library-vicinity
  51.   (let ((library-path
  52.      (or (getenv "SCHEME_LIBRARY_PATH")
  53.          ;; Use this path if your scheme does not support GETENV.
  54.          (case (software-type)
  55.            ((MS-DOS) "c:\\slib\\")
  56.            ((UNIX) "/usr/local/lib/slib/")
  57.            ((VMS) "lib$scheme:")
  58.            (else "")))))
  59.     (lambda () library-path)))
  60.  
  61. ;;; (home-vicinity) should return the vicinity of the user's HOME
  62. ;;; directory, the directory which typically contains files which
  63. ;;; customize a computer environment for a user.
  64.  
  65. (define home-vicinity
  66.   (let ((home-path (getenv "HOME")))
  67.     (lambda () home-path)))
  68.  
  69. ;;; *features* should be set to a list of symbols describing features
  70. ;;; of this implementation.  See Template.scm for the list of feature
  71. ;;; names.
  72.  
  73. (define *features*
  74.       '(
  75.     source                ;can load scheme source files
  76.                     ;(slib:load-source "filename")
  77.     compiled            ;can load compiled files
  78.                     ;(slib:load-compiled "filename")
  79.     rev4-report
  80.     ieee-p1178
  81.     sicp
  82.     rev4-optional-procedures
  83.     rev3-procedures
  84.     rev2-procedures
  85.     multiarg/and-
  86.     multiarg-apply
  87.     rationalize
  88.     object-hash
  89.     delay
  90.     with-file
  91.     string-port
  92.     transcript
  93.     char-ready?
  94.     record
  95.     values
  96.     dynamic-wind
  97.     ieee-floating-point
  98.     full-continuation
  99. ;    sort
  100.     queue
  101.     pretty-print
  102.     object->string
  103.     trace                ;has macros: TRACE and UNTRACE
  104.     defmacro
  105.     compiler
  106.     getenv
  107.     Xwindows
  108.     current-time
  109.     ))
  110.  
  111. (define current-time current-file-time)
  112. (define difftime -)
  113. (define offset-time +)
  114.  
  115. ;;; (OUTPUT-PORT-WIDTH <port>)
  116. (define output-port-width output-port/x-size)
  117.  
  118. ;;; (OUTPUT-PORT-HEIGHT <port>)
  119. (define (output-port-height . arg) 24)
  120.  
  121. ;;; (CURRENT-ERROR-PORT)
  122. (define current-error-port
  123.   (let ((port console-output-port))
  124.     (lambda () port)))
  125.  
  126. ;;; (TMPNAM) makes a temporary file name.
  127. (define tmpnam
  128.   (let ((cntr 100))
  129.     (lambda () (set! cntr (+ 1 cntr))
  130.         (let ((tmp (string-append "slib_" (number->string cntr))))
  131.           (if (file-exists? tmp) (tmpnam) tmp)))))
  132.  
  133. ;;; FORCE-OUTPUT flushes any pending output on optional arg output port.
  134. (define force-output flush-output)
  135. ;;; MITScheme 7.2 is missing flush-output.  Use this instead
  136. ;(define (force-output . arg) #t)
  137.  
  138. ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
  139. ;;; port versions of CALL-WITH-*PUT-FILE.
  140. (define (call-with-output-string proc)
  141.   (let ((co (current-output-port)))
  142.     (with-output-to-string
  143.       (lambda ()
  144.     (let ((port (current-output-port)))
  145.       (with-output-to-port co
  146.         (lambda () (proc port))))))))
  147.  
  148. (define (call-with-input-string string proc)
  149.   (let ((ci (current-input-port)))
  150.     (with-input-from-string string
  151.       (lambda ()
  152.     (let ((port (current-input-port)))
  153.       (with-input-from-port ci
  154.         (lambda () (proc port))))))))
  155.  
  156. (define object->string write-to-string)
  157. (define object->limited-string write-to-string)
  158.  
  159. ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
  160. ;;; be returned by CHAR->INTEGER.  It is defined incorrectly (65536)
  161. ;;; by MITScheme version 8.0.
  162. (define char-code-limit 256)
  163.  
  164. ;;; MOST-POSITIVE-FIXNUM is used in modular.scm
  165. (define most-positive-fixnum #x03FFFFFF)
  166.  
  167. ;;; Return argument
  168. (define (identity x) x)
  169.  
  170. ;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
  171. ;(define (slib:eval form) (eval form (repl/environment (nearest-repl))))
  172. (define (slib:eval form) (eval form user-initial-environment))
  173.  
  174. (define *macros* '(defmacro))
  175. (define (defmacro? m) (and (memq m *macros*) #t))
  176.  
  177. (syntax-table-define system-global-syntax-table 'defmacro
  178.   (macro defmacargs
  179.     (let ((macname (car defmacargs)) (macargs (cadr defmacargs))
  180.                      (macbdy (cddr defmacargs)))
  181.       `(begin
  182.      (set! *macros* (cons ',macname *macros*))
  183.      (syntax-table-define system-global-syntax-table ',macname
  184.        (macro ,macargs ,@macbdy))))))
  185.  
  186. (define (macroexpand-1 e)
  187.   (if (pair? e) (let ((a (car e)))
  188.           (if (and (symbol? a) (defmacro? a))
  189.               (apply (syntax-table-ref system-global-syntax-table a)
  190.                  (cdr e))
  191.               e))
  192.       e))
  193.  
  194. (define (macroexpand e)
  195.   (if (pair? e) (let ((a (car e)))
  196.           (if (and (symbol? a) (defmacro? a))
  197.               (macroexpand
  198.                (apply (syntax-table-ref system-global-syntax-table a)
  199.                   (cdr e)))
  200.               e))
  201.       e))
  202.  
  203. (define gentemp
  204.   (let ((*gensym-counter* -1))
  205.     (lambda ()
  206.       (set! *gensym-counter* (+ *gensym-counter* 1))
  207.       (string->symbol
  208.        (string-append "slib:G" (number->string *gensym-counter*))))))
  209.  
  210. (define defmacro:eval slib:eval)
  211. (define defmacro:load load)
  212. ;;; If your implementation provides R4RS macros:
  213. ;(define macro:eval slib:eval)
  214. ;(define macro:load load)
  215.  
  216. (define (slib:eval-load <pathname> evl)
  217.   (if (not (file-exists? <pathname>))
  218.       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  219.   (call-with-input-file <pathname>
  220.     (lambda (port)
  221.       (let ((old-load-pathname *load-pathname*))
  222.     (set! *load-pathname* <pathname>)
  223.     (do ((o (read port) (read port)))
  224.         ((eof-object? o))
  225.       (evl o))
  226.     (set! *load-pathname* old-load-pathname)))))
  227.  
  228. (define record-modifier record-updater)    ;some versions need this?
  229.  
  230. (define slib:warn
  231.   (lambda args
  232.     (let ((port (current-error-port)))
  233.       (display "Warn: " port)
  234.       (for-each (lambda (x) (display x port)) args))))
  235.  
  236. ;; define an error procedure for the library
  237. (define (slib:error . args)
  238.   (apply error-procedure (append args (list (the-environment)))))
  239.  
  240. ;; define these as appropriate for your system.
  241. (define slib:tab (integer->char 9))
  242. (define slib:form-feed (integer->char 12))
  243.  
  244. (define in-vicinity string-append)
  245.  
  246. ;;; Define SLIB:EXIT to be the implementation procedure to exit or
  247. ;;; return if exitting not supported.
  248. (define slib:exit
  249.   (lambda args
  250.     (cond ((null? args) (exit))
  251.       ((eqv? #t (car args)) (exit))
  252.       ((and (number? (car args)) (integer? (car args))) (exit (car args)))
  253.       (else (exit 1)))))
  254.  
  255. ;;; Here for backward compatability
  256.  
  257. (define (scheme-file-suffix) ".scm")
  258.  
  259. ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
  260. ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
  261.  
  262. (define slib:load-source load)
  263.  
  264. ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
  265. ;;; by compiling "foo.scm" if this implementation can compile files.
  266. ;;; See feature 'COMPILED.
  267.  
  268. (define slib:load-compiled load)
  269.  
  270. ;;; At this point SLIB:LOAD must be able to load SLIB files.
  271.  
  272. (define slib:load slib:load-source)
  273.  
  274. (slib:load (in-vicinity (library-vicinity) "require.scm"))
  275.